home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / cdplay.exe / CDUNIT_P.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1993-03-27  |  15.6 KB  |  722 lines
  1. {$X+}
  2.  
  3. Unit CDUnit_P;
  4.  
  5. Interface
  6.  
  7. {Include the appropriate units.}
  8.  
  9. {$IfDef Windows}
  10. {$C PRELOAD}
  11. Uses Strings, WinCRT, WinDOS, WinProcs, SimRMI, CD_Vars;
  12. {$EndIf}
  13. {$IfDef DPMI}
  14. Uses Strings, CRT, DOS, WinAPI, SimRMI, CD_Vars;
  15. {$EndIf}
  16. {$IfDef MSDOS}
  17. Uses Strings, CRT, DOS, CD_Vars;
  18. {$EndIf}
  19.  
  20. Var
  21.   Drive   : Integer;  { Must set drive before all operations }
  22.   SubUnit : Integer;
  23.  
  24. function File_Name(var Code : Integer) : String;
  25.  
  26. function Read_VTOC(var VTOC : VTOCArray;
  27.                    var Index : Integer) : Boolean;
  28.  
  29. procedure CD_Check(var Code : Integer);
  30.  
  31. procedure Vol_Desc(Var Code : Integer;
  32.                    var ErrCode : Integer);
  33.  
  34. procedure Get_Dir_Entry(PathName : String;
  35.                         var Format, ErrCode : Integer);
  36.  
  37. procedure DeviceStatus;
  38.  
  39. procedure Audio_Channel_Info;
  40.  
  41. procedure Audio_Disk_Info;
  42.  
  43. procedure Audio_Track_Info(Var StartPoint : LongInt;
  44.                            Var TrackControl : Byte);
  45.  
  46. procedure Audio_Status_Info;
  47.  
  48. procedure Q_Channel_Info;
  49.  
  50. procedure Lock(LockDrive : Boolean);
  51.  
  52. procedure Reset;
  53.  
  54. procedure Eject;
  55.  
  56. procedure CloseTray;
  57.  
  58. procedure Resume_Play;
  59.  
  60. procedure Pause_Audio;
  61.  
  62. procedure Play_Audio(StartSec, EndSec : LongInt);
  63.  
  64. function StopAudio : Boolean;
  65.  
  66. function Sector_Size(ReadMode : Byte) : Word;
  67.  
  68. function Volume_Size : LongInt;
  69.  
  70. function Media_Changed : Boolean;
  71.  
  72. function Head_Location(AddrMode : Byte) : LongInt;
  73.  
  74. procedure Read_Drive_Bytes(Var ReadBytes : DriveByteArray);
  75.  
  76. function UPC_Code : String;
  77.  
  78. Implementation
  79.  
  80. Const
  81.   CarryFlag  = $0001;
  82.  
  83. Var
  84. {$IfDef MSDOS}
  85.   Regs       : Registers;
  86. {$Else}
  87.   Regs       :TRealModeRecord; { from SimRMI Unit }
  88. {$EndIf}
  89.   DOSOffset,
  90.   DOSSegment,
  91.   DOSSelector:Word;
  92.   AllocateLong:Longint;
  93.   IOBlock    : Pointer;
  94.  
  95.  
  96. {$IfDef MSDOS}
  97. { standard DOS routines for segments and pointers }
  98. function GetIOBlock(var Block : Pointer; Size : Word) : Boolean;
  99. begin
  100.   GetMem(Block, Size);
  101.   DOSSegment := Seg(Block^);
  102.   DOSOffset := Ofs(Block^);
  103.   GetIOBlock := TRUE;
  104. end;
  105.  
  106. function FreeIOBlock(var Block: Pointer) : Boolean;
  107. begin
  108.   FreeMem(Block, SizeOf(Block^));
  109.   DOSSegment := 0;
  110.   DOSSelector := 0;
  111.   DOSOffset := 0;
  112.   FreeIOBlock := TRUE;
  113. end;
  114.  
  115. {$ELSE}
  116.  
  117. { Get a block in DOS and set pointer values.  DOSSelector is used
  118.   to access the block under protected mode.  DOSSegment accesses the
  119.   block in real mode }
  120.  
  121. function GetIOBlock(var Block : Pointer; Size : Word) : Boolean;
  122. begin
  123.   AllocateLong:=GlobalDOSAlloc(Size); { enough extra room for string }
  124.   If AllocateLong<>0 Then  {If allocation was successful...}
  125.   Begin
  126.      DOSSegment:=AllocateLong SHR 16;     {Get the real mode segment of the memory}
  127.      DOSSelector:=AllocateLong AND $FFFF; {Get the protected mode selector of the memory}
  128.      DOSOffset := 0;
  129.      Block := Ptr(DOSSelector, 0);
  130.      GetIOBlock := TRUE;
  131.   End
  132.   ELSE
  133.      GetIOBlock := FALSE;
  134. end;
  135.  
  136. { Free the DOS block and dereference the pointer }
  137.  
  138. function FreeIOBlock(var Block: Pointer) : Boolean;
  139. begin
  140.   DOSSelector := GlobalDOSFree(DOSSelector);
  141.   DOSSegment := 0;
  142.   Block := NIL;
  143.   FreeIOBlock := (DOSSelector = 0);
  144. end;
  145.  
  146. {$EndIf}
  147.  
  148. procedure Clear_Regs;
  149. begin
  150.   FillChar(Regs, SizeOf(Regs), #0);
  151. end;
  152.  
  153. procedure CD_Intr;
  154. begin
  155.   Regs.AH := $15;
  156.  
  157. {$IfDef MSDOS}
  158.   Intr($2F, Regs);  { Call DOS normally }
  159. {$Else}
  160.   If NOT SimRealModeInt($2F,@Regs) Then    {Call DOS through the DPMI}
  161.      Halt(100);
  162. {$EndIf}
  163. end;
  164.  
  165. procedure MSCDEX_Ver;
  166. begin
  167.   Clear_Regs;
  168.   Regs.AL := $0C;
  169.   Regs.BX := $0000;
  170.   CD_Intr;
  171.   MSCDEX_Version.Minor := 0;
  172.   If Regs.BX = 0 Then
  173.      MSCDEX_Version.Major := 1
  174.   ELSE
  175.      Begin
  176.        MSCDEX_Version.Major := Regs.BH;
  177.        MSCDEX_Version.Minor := Regs.BL;
  178.      End;
  179. end;
  180.  
  181. procedure Initialize;
  182. begin
  183.   NumberOfCD := 0;
  184.   Clear_Regs;
  185.   Regs.AL := $00;
  186.   Regs.BX := $0000;
  187.   CD_Intr;
  188.   If Regs.BX <> 0 THEN
  189.      Begin
  190.        NumberOfCD := Regs.BX;
  191.        FirstCD := Regs.CX;
  192.        Clear_Regs;
  193.        FillChar(DriverList, SizeOf(DriverList), #0);
  194.        FillChar(UnitList, SizeOf(UnitList), #0);
  195.        Regs.AL := $01;               { Get List of Driver Header Addresses }
  196.        Regs.ES := Seg(DriverList);
  197.        Regs.BX := Ofs(DriverList);
  198.        CD_Intr;
  199.        Clear_Regs;
  200.        Regs.AL := $0D;               { Get List of CD-ROM Units }
  201.        Regs.ES := Seg(UnitList);
  202.        Regs.BX := Ofs(UnitList);
  203.        CD_Intr;
  204.        MSCDEX_Ver;
  205.      End;
  206. end;
  207.  
  208.  
  209. function File_Name(var Code : Integer) : String;
  210. Var
  211.   FN : Pointer;
  212. begin
  213.   Clear_Regs;
  214.   If NOT GetIOBlock(FN, 64) THEN
  215.      Exit;
  216.   FillChar(FN, SizeOf(FN), #0);
  217.   Regs.AL := Code + 1;
  218. {
  219.        Copyright Filename     =  1
  220.        Abstract Filename      =  2
  221.        Bibliographic Filename =  3
  222. }
  223.   Regs.CX := Drive;
  224.   Regs.ES := DOSSegment;
  225.   Regs.BX := DOSOffset;
  226.   CD_Intr;
  227.   Code := Regs.AX;
  228.   If (Regs.Flags AND CarryFlag) = 0 THEN
  229.      File_Name := StrPas(FN)
  230.   ELSE
  231.      File_Name := '';
  232.   FreeIOBlock(FN);
  233. end;
  234.  
  235.  
  236. function Read_VTOC(var VTOC : VTOCArray;
  237.                    var Index : Integer) : Boolean;
  238. { On entry -
  239.      Index = Vol Desc Number to read from 0 to ?
  240.   On return
  241.      Case Index of
  242.             1    : Standard Volume Descriptor
  243.             $FF  : Volume Descriptor Terminator
  244.             0    : All others
  245. }
  246. var
  247.   PVTOC : Pointer;
  248.  
  249. begin
  250.   Clear_Regs;
  251.   If NOT GetIOBlock(PVTOC, SizeOf(VTOCArray)) THEN
  252.      Exit;
  253.   FillChar(PVTOC^, SizeOf(PVTOC^), #0);
  254.   Regs.AL := $05;
  255.   Regs.CX := Drive;
  256.   Regs.DX := Index;
  257.   Regs.ES := DOSSegment;
  258.   Regs.BX := DOSOffset;
  259.   CD_Intr;
  260.   Index := Regs.AX;
  261.   Move(PVTOC^,VTOC, SizeOf(VTOC));
  262.   If (Regs.Flags AND CarryFlag) = 0 THEN
  263.      Read_VTOC := TRUE
  264.   ELSE
  265.      Read_VTOC := FALSE;
  266.   FreeIOBlock(PVTOC);
  267. end;
  268.  
  269. procedure CD_Check(var Code : Integer);
  270. begin
  271.   Clear_Regs;
  272.   Regs.AL := $0B;
  273.   Regs.BX := $0000;
  274.   Regs.CX := Drive;
  275.   CD_Intr;
  276.   If Regs.BX <> $ADAD THEN
  277.      Code := 2
  278.   ELSE
  279.      Begin
  280.        If Regs.AX <> 0 THEN
  281.           Code := 0
  282.        ELSE
  283.           Code := 1;
  284.      End;
  285. end;
  286.  
  287.  
  288. procedure Vol_Desc(Var Code : Integer;
  289.                    var ErrCode : Integer);
  290.  
  291.   function Get_Vol_Desc : Byte;
  292.     begin
  293.       Clear_Regs;
  294.       Regs.CX := Drive;
  295.       Regs.AL := $0E;
  296.       Regs.BX := $0000;
  297.       CD_Intr;
  298.       Code := Regs.AX;
  299.       If (Regs.Flags AND CarryFlag) <> 0 THEN
  300.          ErrCode := $FF;
  301.       Get_Vol_Desc := Regs.DH;
  302.     end;
  303.  
  304. begin
  305.   Clear_Regs;
  306.   ErrCode := 0;
  307.   If Code <> 0 THEN
  308.      Begin
  309.        Regs.DH := Code;
  310.        Regs.DL := 0;
  311.        Regs.BX := $0001;
  312.        Regs.AL := $0E;
  313.        Regs.CX := Drive;
  314.        CD_Intr;
  315.        Code := Regs.AX;
  316.        If (Regs.Flags AND CarryFlag) <> 0 THEN
  317.           ErrCode := $FF;
  318.      End;
  319.   If ErrCode = 0 THEN
  320.      Code := Get_Vol_Desc;
  321. end;
  322.  
  323. procedure Get_Dir_Entry(PathName : String;
  324.                         var Format, ErrCode : Integer);
  325. var
  326.   PN : PChar;
  327.   DB : Pointer;
  328. begin
  329.   FillChar(DirBuf, SizeOf(DirBuf), #0);
  330.   PathName := PathName + #0;
  331.   If NOT GetIOBlock(DB, SizeOf(DirBufRec) + 256) THEN
  332.      Exit;
  333.   PN := Ptr(DOSSelector, SizeOf(DirBufRec) + 1);
  334.   Clear_Regs;
  335.   Regs.AL := $0F;
  336.   Regs.CL := Drive;
  337.   Regs.CH := 1;
  338.   Regs.ES := DOSSegment;
  339.   Regs.BX := SizeOf(DirBufRec) + 1;
  340.   Regs.SI := DOSSegment;
  341.   Regs.DI := DOSOffset;
  342.   CD_Intr;
  343.   ErrCode := Regs.AX;
  344.   If (Regs.Flags AND CarryFlag) = 0 THEN
  345.   Begin
  346.     Move(DB^, DirBuf, SizeOf(DirBuf));
  347.     Move(DirBuf.NameArray[1], DirBuf.FileName[1], 38);
  348.     DirBuf.FileName[0] := #12; { File names are only 8.3 }
  349.     Format := Regs.AX
  350.   End
  351.   ELSE
  352.     Format := $FF;
  353.   FreeIOBlock(DB);
  354. end;
  355.  
  356. function IO_Control(Command, NumberOfBytes, TransferBytes,
  357.                      ReturnBytes, StartPoint : Byte;
  358.                      var Bytes, TransferBlock): Byte;
  359. var
  360.   I : Word;
  361. begin
  362.   If NOT GetIOBlock(IOBlock, SizeOf(IOControlBlock)) THEN
  363.      Exit;
  364.   With IOControlBlock(IOBlock^) DO
  365.   Begin
  366.     I := Ofs(TransBlock[1]) - Ofs(IOReq_Hdr);
  367.     NumBytes := NumberOfBytes;
  368.     IOReq_Hdr.Len := 26;
  369.     IOReq_Hdr.SubUnit := SubUnit;
  370.     IOReq_Hdr.Status := 0;
  371.     TransAddr := Ptr(DOSSegment, I); { 23 bytes into the IOBlock^ }
  372.     IOReq_Hdr.Command := Command;
  373.     Move(Bytes, TransBlock[1], TransferBytes);
  374.     Clear_Regs;
  375.     Regs.AL := $10;
  376.     Regs.CX := Drive;
  377.     Regs.ES := DOSSegment;
  378.     Regs.BX := DOSOffset;
  379.     CD_Intr;
  380.     Busy := (IOReq_Hdr.Status AND 512) <> 0;
  381.     If ((IOReq_Hdr.Status AND 32768) <> 0) THEN
  382.        I := IOReq_Hdr.Status AND $FF
  383.     ELSE
  384.         I := 0;
  385.     If ReturnBytes <> 0 THEN
  386.        Move(TransBlock[StartPoint], TransferBlock, ReturnBytes);
  387.   End;
  388.   IO_Control := I;
  389.   FreeIOBlock(IOBlock);
  390. end;
  391.  
  392. procedure Audio_Channel_Info;
  393. var
  394.   Bytes : Byte;
  395. begin
  396.   Bytes := 4;
  397.   IO_Control(IOCtlInput, 9, 1, 9, 1, Bytes, AudioChannel);
  398. End;
  399.  
  400. procedure DeviceStatus;
  401. var
  402.   Bytes : Array[1..2] OF Byte;
  403.   Status: Word;
  404. begin
  405.   Bytes[1] := 6;
  406.  
  407.   IO_Control(IOCtlInput, 5, 1, 2, 2, Bytes, Bytes);
  408.   Move(Bytes, Status, 2);
  409.  
  410.   DoorOpen     := Status AND 1 <> 0;
  411.   DoorLocked   := Status AND 2 = 0;
  412.   Audio        := Status AND 16 <> 0;
  413.   AudioManip   := Status AND 256 <> 0;
  414.   DiscInDrive  := Status AND 2048 = 0;
  415.   RedBook      := Status AND 1024 <> 0;
  416. End;
  417.  
  418. procedure Audio_Disk_Info;
  419. var Bytes : Byte;
  420. begin
  421.   Bytes := 10;
  422.   IO_Control(IOCtlInput, 7, 1, 6, 2, Bytes, AudioDiskInfo);
  423.   Playing := Busy;
  424. end;
  425.  
  426. procedure Audio_Track_Info(Var StartPoint : LongInt;
  427.                            Var TrackControl : Byte);
  428. var
  429.   Bytes : Array[1..5] Of BYTE;
  430. begin
  431.   Bytes[1] := 11;
  432.   Bytes[2] := TrackControl;   { Track number }
  433.  
  434.   IO_Control(IOCtlInput, 7, 2, 5, 3, Bytes, Bytes);
  435.   Move(Bytes[1], StartPoint, 4);
  436.   TrackControl := Bytes[5];
  437.  
  438.   Playing := Busy;
  439. end;
  440.  
  441. procedure Q_Channel_Info;
  442. var
  443.   Bytes : Byte;
  444. begin
  445.   Bytes := 12;
  446.   IO_Control(IOCtlInput, 11, 1, 11, 2, Bytes, QChannelInfo);
  447. end;
  448.  
  449. procedure Audio_Status_Info;
  450. var
  451.   Bytes : Array[1..11] Of Byte;
  452. begin
  453.   Bytes[1] := 15;
  454.   IO_Control(IOCtlInput, 11, 1, 8, 2, Bytes, Bytes);
  455.   Paused := (Word(Bytes[2]) AND 1) <> 0;
  456.   Move(Bytes[4], Last_Start, 4);
  457.   Move(Bytes[8], Last_End, 4);
  458.   Playing := Busy;
  459. end;
  460.  
  461. procedure Eject;
  462. var
  463.   Bytes : Byte;
  464. begin
  465.   Bytes := 0;
  466.   IO_Control(IOCtlOutput, 1, 1, 0, 0, Bytes, Bytes);
  467. end;
  468.  
  469. procedure Reset;
  470. var Bytes : Byte;
  471. begin
  472.   Bytes := 2;
  473.   IO_Control(IOCtlOutput, 1, 1, 0, 0, Bytes, Bytes);
  474.   Busy := TRUE;
  475. end;
  476.  
  477. procedure Lock(LockDrive : Boolean);
  478. var
  479.   Bytes : Array[1..2] Of Byte;
  480. begin
  481.   Bytes[1] := 1;
  482.   If LockDrive THEN
  483.      Bytes[2] := 1
  484.   ELSE
  485.      Bytes[2] := 0;
  486.   IO_Control(IOCtlOutput, 2, 2, 0, 0, Bytes, Bytes);
  487. end;
  488.  
  489. procedure CloseTray;
  490. var Bytes : Byte;
  491. begin
  492.   Bytes := 5;
  493.   IO_Control(IOCtlOutput, 1, 1, 0, 0, Bytes, Bytes);
  494. end;
  495.  
  496. Var
  497.   AudioPlay : Pointer;
  498.  
  499.  
  500. function Play(StartLoc, NumSec : LongInt) : Boolean;
  501. begin
  502.  
  503.   If NOT GetIOBlock(AudioPlay, SizeOf(Audio_Play)) THEN
  504.      Exit;
  505.   With Audio_Play(AudioPlay^) DO
  506.   Begin
  507.     APReq.Command := PlayCD;
  508.     APReq.Len := 22;
  509.     APReq.SubUnit := SubUnit;
  510.     Start := StartLoc;
  511.     NumSecs := NumSec;
  512.     AddrMode := 1;
  513.     Regs.AL := $10;
  514.     Regs.CX := Drive;
  515.     Regs.ES := DOSSegment;
  516.     Regs.BX := DOSOffset;
  517.     CD_Intr;
  518.     Play := ((APReq.Status AND 32768) = 0);
  519.   End;
  520.   FreeIOBlock(AudioPlay);
  521. end;
  522.  
  523. procedure Play_Audio(StartSec, EndSec : LongInt);
  524. Var
  525.   SP,
  526.   EP     : LongInt;
  527.   SArray : Array[1..4] Of Byte;
  528.   EArray : Array[1..4] Of Byte;
  529. begin
  530.   Move(StartSec, SArray[1], 4);
  531.   Move(EndSec, EArray[1], 4);
  532.   SP := SArray[3];           { Must use longint or get negative result }
  533.   SP := (SP*75*60) + (SArray[2]*75) + SArray[1];
  534.   EP := EArray[3];
  535.   EP := (EP*75*60) + (EArray[2]*75) + EArray[1];
  536.   EP := EP-SP;
  537.  
  538.   Playing := Play(StartSec, EP);
  539.   Audio_Status_Info;
  540. end;
  541.  
  542. procedure Pause_Audio;
  543. begin
  544.  
  545.   If Playing THEN
  546.      Begin
  547.        If NOT GetIOBlock(AudioPlay, SizeOf(Audio_Play)) THEN
  548.           Exit;
  549.        With Audio_Play(AudioPlay^) DO
  550.        Begin
  551.          APReq.Command := StopPlay;
  552.          APReq.Len := 13;
  553.          APReq.SubUnit := SubUnit;
  554.        End;
  555.        Regs.AL := $10;
  556.        Regs.CX := Drive;
  557.        Regs.ES := DOSSegment;
  558.        Regs.BX := DOSOffset;
  559.        CD_Intr;
  560.        FreeIOBlock(AudioPlay);
  561.      end;
  562.   Audio_Status_Info;
  563.   Playing := FALSE;
  564. end;
  565.  
  566. procedure Resume_Play;
  567. begin
  568.   If NOT GetIOBlock(AudioPlay, SizeOf(Audio_Play)) THEN
  569.      Exit;
  570.   With Audio_Play(AudioPlay^) DO
  571.   Begin
  572.     APReq.Command := ResumePlay;
  573.     APReq.Len := 13;
  574.     APReq.SubUnit := SubUnit;
  575.   End;
  576.   Regs.AL := $10;
  577.   Regs.CX := Drive;
  578.   Regs.ES := DOSSegment;
  579.   Regs.BX := DOSOffset;
  580.   CD_Intr;
  581.   Audio_Status_Info;
  582.   FreeIOBlock(AudioPlay); { free DOS block anbd dereference pointer }
  583. end;
  584.  
  585. function StopAudio : Boolean;
  586. begin
  587.  
  588.   If NOT GetIOBlock(AudioPlay, SizeOf(Audio_Play)) THEN
  589.      Exit;
  590.   With Audio_Play(AudioPlay^) DO
  591.   Begin
  592.     APReq.Command := StopPlay;
  593.     APReq.Len := 13;
  594.     APReq.SubUnit := SubUnit;
  595.     Regs.AL := $10;
  596.     Regs.CX := Drive;
  597.     Regs.ES := DOSSegment;
  598.     Regs.BX := DOSOffset;
  599.     CD_Intr;
  600.     StopAudio := ((APReq.Status AND 32768) = 0);
  601.   End;
  602.   FreeIOBlock(AudioPlay);
  603. end;
  604.  
  605. function Sector_Size(ReadMode : Byte) : Word;
  606. Var
  607.   SecSize : Word;
  608.   Bytes   : Array[1..2] Of Byte;
  609. begin
  610.   Bytes[1] := 7;
  611.   Bytes[2] := ReadMode;
  612.   IO_Control(IOCtlInput, 4, 2, 2, 3, Bytes, SecSize);
  613.   Sector_Size := SecSize;
  614. End;
  615.  
  616. function Volume_Size : LongInt;
  617. Var
  618.   VolSize : LongInt;
  619.   Bytes   : Byte;
  620. begin
  621.   Bytes := 8;
  622.   IO_Control(IOCtlInput, 5, 1, 4, 2, Bytes, VolSize);
  623.   Volume_Size := VolSize;
  624. End;
  625.  
  626. function Media_Changed : Boolean;
  627.  
  628. {  1  :  Media not changed
  629.    0  :  Don't Know
  630.   -1  :  Media changed
  631. }
  632. var
  633.   MedChng : Byte;
  634.   Bytes : Byte;
  635. begin
  636.   Bytes := 9;
  637.   IO_Control(IOCtlInput, 2, 1, 4, 2, Bytes, MedChng);
  638.   Inc(MedChng);
  639.   If MedChng IN [1,0] THEN
  640.      Media_Changed := True
  641.   ELSE
  642.      Media_Changed := False;
  643. End;
  644.  
  645. function Head_Location(AddrMode : Byte) : LongInt;
  646. Var
  647.   HeadLoc : Longint;
  648.   Bytes : Array[1..2] Of Byte;
  649. begin
  650.   Bytes[1] := 1;
  651.   Bytes[2] := AddrMode;
  652.   IO_Control(IOCtlInput, 6, 2, 4, 3, Bytes, HeadLoc);
  653.   Head_Location := HeadLoc;
  654. End;
  655.  
  656. procedure Read_Drive_Bytes(Var ReadBytes : DriveByteArray);
  657. var
  658.   Bytes : Byte;
  659. Begin
  660.   Bytes := 5;
  661.   IO_Control(IOCtlInput, 130, 1, 128, 3, Bytes, ReadBytes);
  662. End;
  663.  
  664. function UPC_Code : String;
  665. Var
  666.   I, J, K : Integer;
  667.   TempStr : String;
  668.   Bytes : Array[1..11] Of Byte;
  669. Begin
  670.   TempStr := '';
  671.   FillChar(Bytes, SizeOf(Bytes), #0);
  672.   Bytes[1] := 14;
  673.   If (IO_Control(IOCtlInput, 11, 1, 11, 1, Bytes, Bytes) <> 0) THEN
  674.      TempStr := 'No UPC Code'
  675.   ELSE
  676.   Begin
  677.     For I := 3 to 9 DO
  678.       Begin
  679.         J := (Bytes[I] AND $F0) SHR 4;
  680.         K := Bytes[I] AND $0F;
  681.         TempStr := TempStr + Chr(J + 48);
  682.         TempStr := TempStr + Chr(K + 48);
  683.       End;
  684.     If Length(TempStr) > 13 THEN
  685.         TempStr := Copy(TempSTr, 1, 13);
  686.   End;
  687.   UPC_Code := TempStr;
  688. End;
  689.  
  690. {************************************************************}
  691. {$IfDef MSDOS}
  692. {$ELSE}
  693. {$F+}
  694. var
  695.   ExitRoutine : Pointer;
  696. procedure MyExit;
  697. begin
  698.   ExitProc := ExitRoutine;
  699.   If DOSSelector <> 0 THEN
  700.   Begin
  701.      GlobalDOSFree(DOSSelector);
  702.      WriteLn('DOS Selector not free');
  703.   End
  704.   ELSE
  705.      WriteLn('DOS Selector free');
  706. end;
  707. {$EndIf}
  708.  
  709. Begin
  710.   NumberOfCD := 0;
  711.   FirstCD := 0;
  712.   FillChar(MSCDEX_Version, SizeOf(MSCDEX_Version), #0);
  713.   Initialize;
  714.   Drive := FirstCD;
  715.   SubUnit := 0;
  716. {$IfDef MSDOS}
  717. {$ELSE}
  718.   ExitRoutine := ExitProc;
  719.   ExitProc := @MyExit;
  720. {$EndIf}
  721. End.
  722.